library(tidyverse)
library(tigris)
library(censusapi)
library(sf)
library(mapview)
library(plotly)
library(leaflet)
options(
tigris_class = "sf",
tigris_use_cache = T
)See https://docs.safegraph.com/docs/social-distancing-metrics for description of changes in V2 data. This is a good time to generally expand beyond the “% completely at home” indicator we’ve focused on, so I’ll be demonstrating how to visualize/interpret a few different fields of information in the dataset.
This is the same as before.
bay_county_names <-
c(
"Alameda",
"Contra Costa",
"Marin",
"Napa",
"San Francisco",
"San Mateo",
"Santa Clara",
"Solano",
"Sonoma"
)
bay_blockgroups <-
bay_county_names %>%
map(function(x){
block_groups("CA",x,progress_bar=F) %>%
pull(GEOID)
}) %>% unlist()
bay_counties <-
counties("CA", cb = F, progress_bar=F) %>%
filter(NAME %in% bay_county_names)
scc_blockgroups <-
block_groups("CA","Santa Clara", cb=F, progress_bar=F) %>%
st_transform('+proj=longlat +datum=WGS84')
# Below uses tracts sent to us by San Jose
sj_tracts <- st_read("P:/SFBI/Data Library/San_Jose/CSJ_Census_Tracts/CSJ_Census_Tracts.shp") %>%
st_as_sf() %>%
st_transform('+proj=longlat +datum=WGS84')
sj_citycouncil_districts <- st_read("P:/SFBI/Data Library/San_Jose/City Council Districts/CITY_COUNCIL_DISTRICTS.shp") %>%
mutate(
id = DISTRICTS %>% as.character()
) %>%
dplyr::select(id) %>%
st_transform('+proj=longlat +datum=WGS84')
sj_blockgroups <-
scc_blockgroups %>%
st_centroid() %>%
st_join(sj_tracts, left = F) %>%
st_join(sj_citycouncil_districts) %>%
st_set_geometry(NULL) %>%
left_join(scc_blockgroups%>% dplyr::select(GEOID), by = "GEOID") %>%
st_as_sf() %>%
transmute(
origin_census_block_group = GEOID %>% as.character(),
DISTRICTS = id
) %>%
st_transform("+proj=longlat +datum=WGS84 +no_defs")
# the spatial join leaves off two blockgroups which are touching district 9. The following code assigns those to district 9
sj_blockgroups$DISTRICTS[is.na(sj_blockgroups$DISTRICTS)] <- 9
# saveRDS(sj_blockgroups, "~/GitHub/stanfordfuturebay.github.io/data/sj_blockgroups.rds")
# sj_blockgroups <- readRDS(gzcon(url("https://github.com/stanfordfuturebay/stanfordfuturebay.github.io/blob/master/data/sj_blockgroups.rds?raw=true")))
# saveRDS(sj_citycouncil_districts, "~/GitHub/stanfordfuturebay.github.io/data/sj_citycouncil_districts.rds")
# sj_citycouncil_districts <-
# readRDS(gzcon(url("https://github.com/stanfordfuturebay/stanfordfuturebay.github.io/blob/master/data/sj_citycouncil_districts.rds?raw=true")))This is the same as we’ve done before, with the v1 data.
bay_socialdistancing <-
readRDS("P:/SFBI/Restricted Data Library/Safegraph/covid19analysis/bay_socialdistancing.rds")
sj_socialdistancing <-
bay_socialdistancing %>%
filter(origin_census_block_group %in% sj_blockgroups$origin_census_block_group)
# saveRDS(sj_socialdistancing, file = "P:/SFBI/Restricted Data Library/Safegraph/covid19analysis/sj_socialdistancing.rds")
# sj_socialdistancing <- readRDS("P:/SFBI/Restricted Data Library/Safegraph/covid19analysis/sj_socialdistancing.rds")Below is all we have been doing for the dashboard thus far – extracting a “% completely at home” number for each block group.
sj_percenthome_bg <-
sj_socialdistancing %>%
mutate(
`% Completely at Home` = (completely_home_device_count/device_count* 100),
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
completely_home_device_count,
device_count,
`% Completely at Home`
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")
# saveRDS(sj_percenthome_bg, "sj_percenthome_bg.rds")
# This can't be shared publicly. The most "exposed" it is is in this private repo.Here’s the plot we’ve been doing.
weekends <-
sj_percenthome_bg %>%
filter(!duplicated(date)) %>%
arrange(date) %>%
mutate(
x =
case_when(
(date %>% as.numeric()) %% 7 == 1 ~ date + 1,
(date %>% as.numeric()) %% 7 == 4 ~ date - 1,
TRUE ~ date
),
y =
ifelse(
(date %>% as.numeric()) %% 7 %in% c(2,3),
150,
0
)
) %>%
dplyr::select(x,y)
data <-
unique(sj_percenthome_bg$date) %>%
map_dfr(function(specificdate){
sj_percenthome_bg_altered <-
sj_percenthome_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
mean_percenthome = mean(sj_percenthome_bg_altered$`% Completely at Home`),
sd_percenthome = sd(sj_percenthome_bg_altered$`% Completely at Home`),
mean_devicecount = mean(sj_percenthome_bg_altered$device_count),
sd_devicecount = sd(sj_percenthome_bg_altered$device_count),
mean_home = mean(sj_percenthome_bg_altered$completely_home_device_count),
sd_home= sd(sj_percenthome_bg_altered$completely_home_device_count)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,90),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~mean_percenthome-sd_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~mean_percenthome+sd_percenthome,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~mean_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(sj_percenthome_bg$date),max(sj_percenthome_bg$date)+1)
),
yaxis = list(
title = "Percent Completely at Home",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,80)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 80,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)And here’s the map we’ve been doing.
blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(0,sj_percenthome_bg %>%
pull(`% Completely at Home`) %>%
unique())
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_percenthome_bg,
pal = blue_pal,
values = ~`% Completely at Home`,
title = paste0("% Completely<br>at Home,<br>",max(sj_percenthome_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_percenthome_bg %>%
filter(date == max(sj_percenthome_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(`% Completely at Home`),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(`% Completely at Home`,"% completely at home"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)There should be no change in this metric from v1 to v2. We’re double checking to make sure.
bay_socialdistancing_v2 <-
readRDS("P:/SFBI/Restricted Data Library/Safegraph/covid19analysis/bay_socialdistancing_v2.rds")
sj_socialdistancing_v2 <-
bay_socialdistancing_v2 %>%
filter(origin_census_block_group %in% sj_blockgroups$origin_census_block_group)
saveRDS(sj_socialdistancing_v2, file = "P:/SFBI/Restricted Data Library/Safegraph/covid19analysis/sj_socialdistancing_v2.rds")
# sj_socialdistancing <- readRDS("P:/SFBI/Restricted Data Library/Safegraph/covid19analysis/sj_socialdistancing.rds")sj_percenthome_bg_v2 <-
sj_socialdistancing_v2 %>%
mutate(
`% Completely at Home` = (completely_home_device_count/device_count* 100),
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
completely_home_device_count,
device_count,
`% Completely at Home`
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")
# saveRDS(sj_percenthome_bg, "sj_percenthome_bg.rds")
# This can't be shared publicly. The most "exposed" it is is in this private repo.Here’s the plot we’ve been doing.
data_v2 <-
unique(sj_percenthome_bg_v2$date) %>%
map_dfr(function(specificdate){
sj_percenthome_bg_altered <-
sj_percenthome_bg_v2 %>%
filter(date == specificdate)
data.frame(
date = specificdate,
mean_percenthome = mean(sj_percenthome_bg_altered$`% Completely at Home`),
sd_percenthome = sd(sj_percenthome_bg_altered$`% Completely at Home`),
mean_devicecount = mean(sj_percenthome_bg_altered$device_count),
sd_devicecount = sd(sj_percenthome_bg_altered$device_count),
mean_home = mean(sj_percenthome_bg_altered$completely_home_device_count),
sd_home= sd(sj_percenthome_bg_altered$completely_home_device_count)
)
}) %>%
arrange(date)
plot_ly(
data = data_v2,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,90),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~mean_percenthome-sd_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~mean_percenthome+sd_percenthome,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~mean_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(sj_percenthome_bg$date),max(sj_percenthome_bg$date)+1)
),
yaxis = list(
title = "Percent Completely at Home",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,80)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 80,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)And here’s the map we’ve been doing, recreated in V2:
blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(0,sj_percenthome_bg_v2 %>%
pull(`% Completely at Home`) %>%
unique())
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_percenthome_bg_v2,
pal = blue_pal,
values = ~`% Completely at Home`,
title = paste0("% Completely<br>at Home,<br>",max(sj_percenthome_bg_v2$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_percenthome_bg_v2 %>%
filter(date == max(sj_percenthome_bg_v2$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(`% Completely at Home`),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(`% Completely at Home`,"% completely at home"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)plot_ly() %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,90),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_percenthome-sd_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "V1, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_percenthome+sd_percenthome,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(211,211,48,0.5)",
line = list(color = "transparent"),
name = "V1, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "V1, Mean",
showlegend=T
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_percenthome-sd_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "V2, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_percenthome+sd_percenthome,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.5)",
line = list(color = "transparent"),
name = "V2, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_percenthome,
type = "scatter",
mode = "lines",
line = list(color = "rgb(255,255,255)"),
name = "V2, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(sj_percenthome_bg$date),max(sj_percenthome_bg$date)+1)
),
yaxis = list(
title = "Percent Completely at Home",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,80)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 80,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)I’ve reached out to Safegraph to understand the source of these differences.
Here are some additional checks the Safegraph team asked me to do:
plot_ly() %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,160),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_devicecount-sd_devicecount,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "V1, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_devicecount+sd_devicecount,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(211,211,48,0.5)",
line = list(color = "transparent"),
name = "V1, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_devicecount,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "V1, Mean",
showlegend=T
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_devicecount-sd_devicecount,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "V2, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_devicecount+sd_devicecount,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.5)",
line = list(color = "transparent"),
name = "V2, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_devicecount,
type = "scatter",
mode = "lines",
line = list(color = "rgb(255,255,255)"),
name = "V2, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(sj_percenthome_bg$date),max(sj_percenthome_bg$date)+1)
),
yaxis = list(
title = "Device count",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,150)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 150,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)Underlying device counts are slightly different.
plot_ly() %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,160),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_home-sd_home,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "V1, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_home+sd_home,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(211,211,48,0.5)",
line = list(color = "transparent"),
name = "V1, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
data = data,
x = ~date,
y = ~mean_home,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "V1, Mean",
showlegend=T
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_home-sd_home,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "V2, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_home+sd_home,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.5)",
line = list(color = "transparent"),
name = "V2, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
data = data_v2,
x = ~date,
y = ~mean_home,
type = "scatter",
mode = "lines",
line = list(color = "rgb(255,255,255)"),
name = "V2, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(sj_percenthome_bg$date),max(sj_percenthome_bg$date)+1)
),
yaxis = list(
title = "Devices Completely at Home",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,100)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 100,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)The Safegraph team responded with the following: “Beginning in v2, for calculating dwell times, we include the portion of any stop (i.e., a dwell event) within the time range regardless of whether the stop or start time was contained in the time period. Previously we only included dwell events with a start time inside the time period. An example of the impact of this change, consider a dwell event that starts at 11pm on day N and lasts until 6am on day N+1. In v1 this dwell event would only be counted on day N, but in v2 this dwell event is counted both for day N and day N+1. As a result the device counts overall slightly increased due to these day-boundary events now being included in both days.”
This would explain the difference, and it would make V2 more “reasonable” than V1. From this point on, I will just use V2 data and explore other outputs.
This would just be the inverse of what we’ve plotted before, but could be better for communication purposes.
sj_socialdistancing <- sj_socialdistancing_v2
sj_percentleavinghome_bg <-
sj_socialdistancing %>%
mutate(
`% Leaving Home` = ((1-completely_home_device_count/device_count)*100) %>% round(1),
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
`% Leaving Home`
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")
# saveRDS(sj_percenthome_bg, "sj_percenthome_bg.rds")
# This can't be shared publicly. The most "exposed" it is is in this private repo.data <-
unique(sj_percentleavinghome_bg$date) %>%
map_dfr(function(specificdate){
sj_percentleavinghome_bg_altered <-
sj_percentleavinghome_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
mean_percentleavinghome = round(mean(sj_percentleavinghome_bg_altered$`% Leaving Home`),digits = 1),
sd_percentleavinghome = round(sd(sj_percentleavinghome_bg_altered$`% Leaving Home`),digits = 1)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,110),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~mean_percentleavinghome-sd_percentleavinghome,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~mean_percentleavinghome+sd_percentleavinghome,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~mean_percentleavinghome,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(sj_percentleavinghome_bg$date),max(sj_percentleavinghome_bg$date)+1)
),
yaxis = list(
title = "Percent Leaving Home",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,100)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 100,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.05,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(0,sj_percentleavinghome_bg %>%
pull(`% Leaving Home`) %>%
unique())
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_percentleavinghome_bg,
pal = blue_pal,
values = ~`% Leaving Home`,
title = paste0("% Leaving<br>Home,<br>",max(sj_percentleavinghome_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_percentleavinghome_bg %>%
filter(date == max(sj_percentleavinghome_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(`% Leaving Home`),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(`% Leaving Home`,"% leaving home"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)This should be similar to % leaving home, but a subset that were seen to be in one location other than home for 3-6 hours.
sj_parttime_bg <-
sj_socialdistancing %>%
mutate(
parttime = part_time_work_behavior_devices/device_count*100,
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
parttime
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")
# saveRDS(sj_percenthome_bg, "sj_percenthome_bg.rds")
# This can't be shared publicly. The most "exposed" it is is in this private repo.data <-
unique(sj_parttime_bg$date) %>%
map_dfr(function(specificdate){
data_specificdate <-
sj_parttime_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
date_mean = mean(data_specificdate$parttime, na.rm=T),
date_sd = sd(data_specificdate$parttime, na.rm=T)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,110),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~date_mean-date_sd,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~date_mean+date_sd,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~date_mean,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(data$date),max(data$date)+1)
),
yaxis = list(
title = "Percent Part Time Work Behavior",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,30)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 100,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(0,sj_parttime_bg %>%
filter(date == max(sj_parttime_bg$date)) %>%
pull(parttime) %>%
unique())
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_parttime_bg %>%
filter(date == max(sj_parttime_bg$date)),
pal = blue_pal,
values = ~parttime,
title = paste0("% Part<br>Time Work<br>Behavior,<br>",max(sj_parttime_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_parttime_bg %>%
filter(date == max(sj_parttime_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(parttime),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(parttime,"% part time work behavior"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)Same as before, but count of devices that were at one location other than home for more than 6 hours.
sj_fulltime_bg <-
sj_socialdistancing %>%
mutate(
fulltime = full_time_work_behavior_devices/device_count*100,
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
fulltime
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")
# saveRDS(sj_percenthome_bg, "sj_percenthome_bg.rds")
# This can't be shared publicly. The most "exposed" it is is in this private repo.data <-
unique(sj_fulltime_bg$date) %>%
map_dfr(function(specificdate){
data_specificdate <-
sj_fulltime_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
date_mean = mean(data_specificdate$fulltime, na.rm=T),
date_sd = sd(data_specificdate$fulltime, na.rm=T)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,110),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~date_mean-date_sd,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~date_mean+date_sd,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~date_mean,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(data$date),max(data$date)+1)
),
yaxis = list(
title = "Percent Full Time Work Behavior",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,40)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 40,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(0,sj_fulltime_bg %>%
filter(date == max(sj_fulltime_bg$date)) %>%
pull(fulltime) %>%
unique())
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_fulltime_bg %>%
filter(date == max(sj_fulltime_bg$date)),
pal = blue_pal,
values = ~fulltime,
title = paste0("% Full<br>Time Work<br>Behavior,<br>",max(sj_fulltime_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_fulltime_bg %>%
filter(date == max(sj_fulltime_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(fulltime),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(fulltime,"% full time work behavior"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)For the specific day viewed above, there is a strange outlier in downtown SJ with very high full-time work behavior.
Could add together part time and full time work behavior if desired.
sj_working_bg <-
sj_socialdistancing %>%
mutate(
working = (part_time_work_behavior_devices+full_time_work_behavior_devices)/device_count*100,
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
working
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")
# saveRDS(sj_percenthome_bg, "sj_percenthome_bg.rds")
# This can't be shared publicly. The most "exposed" it is is in this private repo.data <-
unique(sj_working_bg$date) %>%
map_dfr(function(specificdate){
data_specificdate <-
sj_working_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
date_mean = mean(data_specificdate$working, na.rm=T),
date_sd = sd(data_specificdate$working, na.rm=T)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,110),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~date_mean-date_sd,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~date_mean+date_sd,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~date_mean,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(data$date),max(data$date)+1)
),
yaxis = list(
title = "Percent Working Behavior",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,80)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 80,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)At first glance, these numbers seem low to me. This measure of “3+ hours at a location other than home” of course is just a proxy for “working” and could be misconceived or inaccurately tracked for many reasons. But this may still be useful for relative comparisons.
blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(0,sj_working_bg %>%
filter(date == max(sj_working_bg$date)) %>%
pull(working) %>%
unique())
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_working_bg %>%
filter(date == max(sj_working_bg$date)),
pal = blue_pal,
values = ~working,
title = paste0("% Working<br>Behavior,<br>",max(sj_working_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_working_bg %>%
filter(date == max(sj_working_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(working),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(working,"% working behavior"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)Similarly, we can take all devices that are not “at home” and not “working” and interpret them as some other kind of travel.
sj_nonworking_bg <-
sj_socialdistancing %>%
mutate(
nonworking = (1-(completely_home_device_count + part_time_work_behavior_devices + full_time_work_behavior_devices)/device_count)*100,
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
nonworking
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")
# saveRDS(sj_percenthome_bg, "sj_percenthome_bg.rds")
# This can't be shared publicly. The most "exposed" it is is in this private repo.data <-
unique(sj_nonworking_bg$date) %>%
map_dfr(function(specificdate){
data_specificdate <-
sj_nonworking_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
date_mean = mean(data_specificdate$nonworking, na.rm=T),
date_sd = sd(data_specificdate$nonworking, na.rm=T)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,110),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~date_mean-date_sd,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~date_mean+date_sd,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~date_mean,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(data$date),max(data$date)+1)
),
yaxis = list(
title = "Percent Non-Working Travel Behavior",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,80)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 80,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.05,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(0,sj_nonworking_bg %>%
filter(date == max(sj_nonworking_bg$date)) %>%
pull(nonworking) %>%
unique())
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_nonworking_bg %>%
filter(date == max(sj_nonworking_bg$date)),
pal = blue_pal,
values = ~nonworking,
title = paste0("% Non-Working<br>Travel<br>Behavior,<br>",max(sj_nonworking_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_nonworking_bg %>%
filter(date == max(sj_nonworking_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(nonworking),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(nonworking,"% non-working travel behavior"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)This data was already in the v1 dataset but we haven’t plotted before.
sj_mediandistance_bg <-
sj_socialdistancing %>%
mutate(
mediandistance = distance_traveled_from_home/1609.34,
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
mediandistance
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")data <-
unique(sj_mediandistance_bg$date) %>%
map_dfr(function(specificdate){
data_specificdate <-
sj_mediandistance_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
date_mean = mean(data_specificdate$mediandistance, na.rm=T),
date_sd = sd(data_specificdate$mediandistance, na.rm=T)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,110),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~date_mean-date_sd,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~date_mean+date_sd,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~date_mean,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(data$date),max(data$date)+1)
),
yaxis = list(
title = "Median miles traveled from home",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,20)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 20,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)The range is very wide on this measure because individual devices may be going to very different places including outside of the Bay Area. Also, this “median” is “of the devices that left home that day”, so it doesn’t really weight correctly on top of the full population. For these reasons and more, it’s probably not a very useful measure to communicate.
Here’s a map, for what it’s worth. There’s one outlier block group with a very high median distance traveled that distorts continuous color range, so I’ve switched to quantiles.
blue_pal <- colorQuantile(
palette = "Blues",
domain =
c(
0,
sj_mediandistance_bg %>%
filter(date == max(sj_mediandistance_bg$date)) %>%
pull(mediandistance) %>%
unique()
),
n = 5
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_mediandistance_bg %>%
filter(date == max(sj_mediandistance_bg$date)) ,
pal = blue_pal,
values = ~mediandistance,
title = paste0("Median<br>miles<br>traveled<br>from home,<br>",max(sj_mediandistance_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_mediandistance_bg %>%
filter(date == max(sj_mediandistance_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(mediandistance),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(round(mediandistance)," miles traveled from home, median"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)This data was already in the v1 dataset but we haven’t plotted before.
sj_mediandwell_bg <-
sj_socialdistancing %>%
mutate(
mediandwell = median_home_dwell_time/60,
date = date_range_start %>% substr(1,10) %>% as.Date()
) %>%
dplyr::select(
origin_census_block_group,
date,
mediandwell
) %>%
left_join(sj_blockgroups %>% st_set_geometry(NULL), by ="origin_census_block_group")data <-
unique(sj_mediandwell_bg$date) %>%
map_dfr(function(specificdate){
data_specificdate <-
sj_mediandwell_bg %>%
filter(date == specificdate)
data.frame(
date = specificdate,
date_mean = mean(data_specificdate$mediandwell, na.rm=T),
date_sd = sd(data_specificdate$mediandwell, na.rm=T)
)
}) %>%
arrange(date)
plot_ly(
data = data,
x = ~date
) %>%
add_trace(
x = weekends$x,
y = weekends$y,
type = "scatter",
mode = "lines",
fill = "tozeroy",
fillcolor = "rgba(112,112,112,0.25)",
line = list(color = "transparent"),
name = "Weekends",
showlegend=T
) %>%
add_trace(
x = c("2020-03-16" %>% as.Date(),"2020-03-16" %>% as.Date()),
y = c(-10,110),
type = "scatter",
mode = "lines",
line = list(color = "rgb(63,63,63)",dash = "dot"),
name = "Santa Clara County Shelter-in-Place Order",
showlegend=F
) %>%
add_trace(
y = ~date_mean-date_sd,
type = "scatter",
mode = "lines",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=F
) %>%
add_trace(
y = ~date_mean+date_sd,
type = "scatter",
mode = "lines",
fill = "tonexty",
fillcolor = "rgba(39,128,227,0.25)",
line = list(color = "transparent"),
name = "City, +/- 1 S.D.",
showlegend=T
) %>%
add_trace(
y = ~date_mean,
type = "scatter",
mode = "lines",
line = list(color = "rgb(0,0,0)"),
name = "City, Mean",
showlegend=T
) %>%
layout(
margin = list(t = 50),
paper_bgcolor='rgb(255,255,255)',
plot_bgcolor='rgb(229,229,229)',
xaxis = list(
title = "",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(min(data$date),max(data$date)+1)
),
yaxis = list(
title = "Median hours at home",
gridcolor = 'rgb(255,255,255)',
showgrid = TRUE,
showline = FALSE,
showticklabels = TRUE,
tickcolor = 'rgb(127,127,127)',
ticks = 'outside',
zeroline = FALSE,
fixedrange = T,
range = c(0,24)
),
annotations = list(
xref = "x",
yref = "y",
x = "2020-03-16" %>% as.Date(),
y = 24,
text = "Santa Clara County<br>Shelter-in-Place Order"
),
legend = list(
x = 0.05,
y = 0.95,
bgcolor = 'rgb(229,229,229)'
)
) %>%
config(displayModeBar = F)This doesn’t seem fundamentally different from % completely at home. The “median” strikes me as obfuscating useful information here.
Here’s a map, for what it’s worth.
blue_pal <- colorNumeric(
palette = "Blues",
domain =
c(
0,
sj_mediandwell_bg %>%
filter(date == max(sj_mediandwell_bg$date)) %>%
pull(mediandwell) %>%
unique()
)
)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addMapPane("blocks", 410) %>%
addLegend(
data = sj_mediandwell_bg %>%
filter(date == max(sj_mediandwell_bg$date)) ,
pal = blue_pal,
values = ~mediandwell,
title = paste0("Median<br>hours<br>at home,<br>",max(sj_mediandwell_bg$date)),
opacity = 0.5
) %>%
setView(-121.87,37.30,10) %>%
addPolygons(
data = sj_mediandwell_bg %>%
filter(date == max(sj_mediandwell_bg$date)) %>%
left_join(sj_blockgroups, by ="origin_census_block_group") %>%
st_as_sf(),
# layerId = block_Ids,
fillColor = ~blue_pal(mediandwell),
color = "white",
weight = 0.5,
opacity = 0.5,
fillOpacity = 0.5,
label = ~paste0(round(mediandwell)," hours at home, median"),
highlightOptions =
highlightOptions(
weight = 2.25,
opacity = 1
),
options =
pathOptions(
pane = "blocks"
)
)This field is an array with 24 numbers and allows for an even more granular version of our time plots. It could be useful to see the typical hour-by-hour trend for pre-COVID and post-COVID.
TBD